home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / oasis / oasisegs.lha / egs / tspa.lisp < prev   
Lisp/Scheme  |  1992-04-23  |  3KB  |  69 lines
  1. (proclaim '(type (array fixnum 2) *dist*))
  2. (proclaim '(type (array fixnum 1) *best*))
  3. (proclaim '(type (array fixnum 1) *v*))
  4. (proclaim '(type fixnum           *min*))
  5.  
  6. (proclaim '(function run     (fixnum) fixnum))
  7. (proclaim '(function search  (fixnum fixnum) nil))
  8. (proclaim '(function gen     ((array fixnum 2) fixnum) nil))
  9.  
  10. (defvar *dist* nil)
  11. (defvar *best* nil)
  12. (defvar *v*    nil)
  13. (defvar *min*  65536)
  14.  
  15. (defun run (n)
  16.        (declare (type fixnum n))
  17.        (setf *dist* (make-array (cons n (cons n nil))
  18.                     :element-type 'fixnum
  19.                     :initial-element 0))
  20.        (setf *best* (make-array (cons n nil)
  21.                     :element-type 'fixnum))
  22.        (setf *v*    (make-array (cons n nil)
  23.                     :element-type 'fixnum))
  24.        (setf *min*  65536)
  25.        (gen *dist* *n*)
  26.        (search 0 0) )
  27.  
  28. (defun search (k sum)
  29.        (declare (type fixnum k)
  30.                 (type fixnum sum) )
  31.        (if (= k (- *n* 1))
  32.            (if (> *min* (setf sum (+ sum (aref *dist* (aref *v* k) 0))))
  33.                (do ((i 0 (+ i 1)))
  34.                    ((= i n) (setf *min* sum))
  35.                    (declare (type fixnum i))
  36.                    (setf (aref *best* i) (aref *v* i)) ))
  37.            (do ((i (+ k 1) (+ i 1)))
  38.                ((= i n) nil)
  39.                (declare (type fixnum i))
  40.                (if (> *min* (+ sum (aref *dist* (aref *v* k) (aref *v* i))))
  41.                    (let ((x (aref *v* i))
  42.                          (y (aref *v* (+ k 1))) )
  43.                         (declare (type fixnum x)
  44.                                  (type fixnum y) )
  45.                         (setf (aref *v* i) y)
  46.                         (setf (aref *v* (+ k 1)) x)
  47.                         (search (+ k 1) (+ sum (aref *dist* (aref *v* k) x)))
  48.                         (setf (aref *v* i) x)
  49.                         (setf (aref *v* (+ k 1)) y) )))))
  50.  
  51. (defun gen (mat n)
  52.        (declare (type (array fixnum 2) mat)
  53.                 (type fixnum n) )
  54.        (let ((seed 197)
  55.              (b 0) )
  56.             (declare (type fixnum seed)
  57.                      (type fixnum b) )
  58.             (do ((i 0 (+ i 1)))
  59.                 ((= i n) nil)
  60.                 (declare (type fixnum i))
  61.                 (do ((j (+ i 1) (+ j 1)))
  62.                     ((= j n) (setf (aref *v* i) i))
  63.                     (declare (type fixnum j))
  64.                     (setf seed (rem (+ (* 4757 seed) 1) 32768))
  65.                     (setf b (+ 1 (rem (truncate (/ seed 16)) 256)))
  66.                     (setf (aref mat i j) b)
  67.                     (setf (aref mat j i) b) ))))
  68.  
  69.